home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / MacPerl 506 appl folder.sit / MacPerl 506 appl folder / Mac_Perl_506r1m_appl / lib / AutoSplit.pm < prev    next >
Text File  |  1995-03-19  |  7KB  |  232 lines
  1. package AutoSplit;
  2.  
  3. require 5.000;
  4. require Exporter;
  5.  
  6. use Config;
  7. use Carp;
  8.  
  9. @ISA = qw(Exporter);
  10. @EXPORT = qw(&autosplit &autosplit_lib_modules);
  11. @EXPORT_OK = qw($Verbose $Keep);
  12.  
  13. # for portability warn about names longer than $maxlen
  14. $Maxlen  = 28;    # 8 for dos, 11 (14-".al") for SYSVR3, 28 for Mac
  15. $Verbose = 2;    # 0=none, 1=minimal, 2=list .al files
  16. $Keep    = 0;
  17. $IndexFile = "autosplit.ix";    # file also serves as timestamp
  18.  
  19. $maxflen = 255;
  20. $maxflen = 14 if $Config{'d_flexfnam'} ne 'define';
  21. $vms = ($Config{'osname'} eq 'VMS');
  22.  
  23. sub autosplit{
  24.     my($file, $autodir) = @_;
  25.     autosplit_file($file, $autodir, $Keep, 1, 0);
  26. }
  27.  
  28.  
  29.  
  30. # This function is used during perl building/installation
  31. # ./miniperl -e 'use AutoSplit; autosplit_modules(@ARGV)' ...
  32.  
  33. sub autosplit_lib_modules{
  34.     my(@modules) = @_; # list of Module names
  35.  
  36.     foreach(@modules){
  37. #    s#::#/#g;    # incase specified as ABC::XYZ
  38. #    s#^lib/##; # incase specified as lib/*.pm
  39. #    autosplit_file("lib/$_", "lib/auto", $Keep, 1, 1);
  40.     s#::#:#g;    # incase specified as ABC::XYZ
  41.     s#^:lib:##; # incase specified as :lib:*.pm
  42.     autosplit_file(":lib:$_", ":lib:auto", $Keep, 1, 1);
  43.     }
  44.     0;
  45. }
  46.  
  47.  
  48. # private functions
  49.  
  50. sub autosplit_file{
  51.     my($filename, $autodir, $keep, $check_for_autoloader, $check_mod_time) = @_;
  52.     my(@names);
  53.  
  54.     # where to write output files
  55. #    $autodir = "lib/auto" unless $autodir;
  56.     $autodir = ":lib:auto" unless $autodir;
  57.     die "autosplit directory $autodir does not exist" unless -d $autodir;
  58.  
  59.     # allow just a package name to be used
  60.     $filename .= ".pm" unless ($filename =~ m/¥.pm$/);
  61.  
  62.     open(IN, "<$filename") || die "AutoSplit: Can't open $filename: $!¥n";
  63.     my($pm_mod_time) = (stat($filename))[9];
  64.     my($autoloader_seen) = 0;
  65.     while (<IN>) {
  66.     # record last package name seen
  67.     $package = $1 if (m/^¥s*package¥s+([¥w:]+)¥s*;/);
  68.     ++$autoloader_seen if m/^¥s*use¥s+AutoLoader¥b/;
  69.     ++$autoloader_seen if m/¥bISA¥s*=.*¥bAutoLoader¥b/;
  70.     last if /^__END__/;
  71.     }
  72.     return 0 if ($check_for_autoloader && !$autoloader_seen);
  73.     $_ or die "Can't find __END__ in $filename¥n";
  74.  
  75.     $package or die "Can't find 'package Name;' in $filename¥n";
  76.  
  77. #    my($modpname) = $package; $modpname =~ s#::#/#g;
  78. #    my($al_idx_file) = "$autodir/$modpname/$IndexFile";
  79.     my($modpname) = $package; $modpname =~ s#::#:#g;
  80.     my($al_idx_file) = "$autodir:$modpname:$IndexFile";
  81.  
  82.     die "Package $package does not match filename $filename"
  83.         unless ($filename =~ m/$modpname.pm$/);
  84.  
  85.     if ($check_mod_time){
  86.     my($al_ts_time) = (stat("$al_idx_file"))[9] || 1;
  87.     if ($al_ts_time >= $pm_mod_time){
  88.         print "AutoSplit skipped ($al_idx_file newer that $filename)¥n"
  89.         if ($Verbose >= 2);
  90.         return undef;    # one undef, not a list
  91.     }
  92.     }
  93.  
  94.     my($from) = ($Verbose>=2) ? "$filename => " : "";
  95. #    print "AutoSplitting $package ($from$autodir/$modpname)¥n"
  96. #    if $Verbose;
  97.     print "AutoSplitting $package ($from$autodir:$modpname)¥n"
  98.     if $Verbose;
  99.  
  100. #    unless (-d "$autodir/$modpname"){
  101.     unless (-d "$autodir:$modpname"){
  102.     local($", @p)=":";
  103. #    foreach(split(m|:|,"$autodir/$modpname")){
  104.     foreach(split(/:/,"$autodir:$modpname")){
  105.         push(@p, $_);
  106.         next if -d "@p";
  107.         mkdir("@p",0777) or die "AutoSplit unable to mkdir @p: $!";
  108.     }
  109.     }
  110.  
  111.     # We must try to deal with some SVR3 systems with a limit of 14
  112.     # characters for file names. Sadly we *cannot* simply truncate all
  113.     # file names to 14 characters on these systems because we *must*
  114.     # create filenames which exactly match the names used by AutoLoader.pm.
  115.     # This is a problem because some systems silently truncate the file
  116.     # names while others treat long file names as an error.
  117.  
  118.     # We do not yet deal with multiple packages within one file.
  119.     # Ideally both of these styles should work.
  120.     #
  121.     #   package NAME;
  122.     #   __END__
  123.     #   sub AAA { ... }
  124.     #   package NAME::option1;
  125.     #   sub BBB { ... }
  126.     #   package NAME::option2;
  127.     #   sub BBB { ... }
  128.     #
  129.     #   package NAME;
  130.     #   __END__
  131.     #   sub AAA { ... }
  132.     #   sub NAME::option1::BBB { ... }
  133.     #   sub NAME::option2::BBB { ... }
  134.     #
  135.     # For now both of these produce warnings.
  136.  
  137. #    open(OUT,">/dev/null"); # avoid 'not opened' warning
  138.     open(OUT,">Dev:Null"); # avoid 'not opened' warning
  139.     my(@subnames);
  140.     while (<IN>) {
  141.     if (/^package ([¥w:]+)¥s*;/) {
  142.         warn "package $1; in AutoSplit section ignored. Not currently supported.";
  143.     }
  144.     if (/^sub ([¥w:]+)/) {
  145.         print OUT "1;¥n";
  146.         my($subname) = $1;
  147.         if ($subname =~ m/::/){
  148.         warn "subs with package names not currently supported in AutoSplit section";
  149.         }
  150.         push(@subnames, $subname);
  151.         my($lname, $sname) = ($subname, substr($subname,0,$maxflen-3));
  152. #        my($lpath) = "$autodir/$modpname/$lname.al";
  153. #        my($spath) = "$autodir/$modpname/$sname.al";
  154.         my($lpath) = "$autodir:$modpname:$lname.al";
  155.         my($spath) = "$autodir:$modpname:$sname.al";
  156.         unless(open(OUT, ">$lpath")){
  157.         open(OUT, ">$spath") or die "Can't create $spath: $!¥n";
  158.         push(@names, $sname);
  159.         print "  writing $spath (with truncated name)¥n"
  160.             if ($Verbose>=1);
  161.         }else{
  162.         push(@names, $lname);
  163.         print "  writing $lpath¥n" if ($Verbose>=2);
  164.         }
  165.         print OUT "# NOTE: Derived from $filename.  ",
  166.             "Changes made here will be lost.¥n";
  167.         print OUT "package $package;¥n¥n";
  168.     }
  169.     print OUT $_;
  170.     }
  171.     print OUT "1;¥n";
  172.     close(OUT);
  173.     close(IN);
  174.  
  175.     if (!$keep){  # don't keep any obsolete *.al files in the directory
  176.     my(%names);
  177.     @names{@names} = @names;
  178.     opendir(OUTDIR,"$autodir:$modpname");
  179.     foreach(sort readdir(OUTDIR)){
  180.         next unless /¥.al$/;
  181.         my($subname) = m/(.*)¥.al$/;
  182.         next if $names{substr($subname,0,$maxflen-3)};
  183.         my($file) = "$autodir/$modpname/$_";
  184.         print "  deleting $file¥n" if ($Verbose>=2);
  185.         unlink $file or carp "Unable to delete $file: $!";
  186.     }
  187.     closedir(OUTDIR);
  188.     }
  189.  
  190.     open(TS,">$al_idx_file") or
  191.     carp "AutoSplit: unable to create timestamp file ($al_idx_file): $!";
  192.     print TS "# Index created by AutoSplit for $filename (file acts as timestamp)¥n";
  193.     print TS map("sub $_ ;¥n", @subnames);
  194.     close(TS);
  195.  
  196.     check_unique($package, $Maxlen, 1, @names);
  197.  
  198.     @names;
  199. }
  200.  
  201.  
  202. sub check_unique{
  203.     my($module, $maxlen, $warn, @names) = @_;
  204.     my(%notuniq) = ();
  205.     my(%shorts)  = ();
  206.     my(@toolong) = grep(length > $maxlen, @names);
  207.  
  208.     foreach(@toolong){
  209.     my($trunc) = substr($_,0,$maxlen);
  210.     $notuniq{$trunc}=1 if $shorts{$trunc};
  211.     $shorts{$trunc} = ($shorts{$trunc}) ? "$shorts{$trunc}, $_" : $_;
  212.     }
  213.     if (%notuniq && $warn){
  214.     print "$module: some names are not unique when truncated to $maxlen characters:¥n";
  215.     foreach(keys %notuniq){
  216.         print " $shorts{$_} truncate to $_¥n";
  217.     }
  218.     }
  219.     %notuniq;
  220. }
  221.  
  222. 1;
  223. __END__
  224.  
  225. # test functions so AutoSplit.pm can be applied to itself:
  226. sub test1{ "test 1¥n"; }
  227. sub test2{ "test 2¥n"; }
  228. sub test3{ "test 3¥n"; }
  229. sub test4{ "test 4¥n"; }
  230.  
  231.  
  232.